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Examples  of 
Concurrent  Programs 

Michael  B.  Feldman 
The  George  Washington  University 


The  first  example  is  an  implementation  in  each  of  four  langn^ages  (Ada,  Concurrent  C, 
Co-Pascal,  and  occam)  of  the  famous  Dining  Philosophers  problem  first  stated  by 
'D^Stra^.  In  this  metaphorical  statement  of  deadlock  and  resource  allocation  problems, 
five  philosophers  sit  around  a  circular  table,  in  the  center  of  which  is  a  infinitely  large 
bowl  of  Chinese  food.  To  the  left  and  right  of  each  philosopher  is  a  single  chopstick; 
each  philosopher  must  try  to  acquire  both  chopsticks,  eat  for  awhile,  then  put  down  the 
chopsticks  and  think  for  awhile;  this  cycle  repeats  for  some  total  number  of  meals. 
(Dijkstra’s  original  formulation  used  spaghetti  and  forks;  we  prefer  the  chopstick  setting 
because  most  people  can  eat  spaghetti  with  one  fork.)  The  algorithm  for  chopstick 
selection  must  be  chosen  carefully,  otherwise  if  all  philosophers  grab,  say,  their  left 
chopsticks  and  refuse  to  yield  them,  all  will  starve!  ')  ^  q_ 

'  ■  -  C  7' 

'The  second  example  is  one  we  have  used  With  repeated  success  at  The  George 
Washington  University,  namely  a  ^sort  race’^'in  which  three  different  sorting  methods 
are  activated  as  processes.  Each  sort  displays  its  progress  in  its  ^window”  (usually  a 
single  row)  on  the  terminal;  mutual  exclusion  is  necessary  to  protect  the  screen,  which 
is  a  writable  shared  resource.  We  have  found  this  example  interesting  and  fun-there  is 
a  lot  of  screen  activity,  the  problem  being  solved  is  obvious,  and  the  three  independent 
sorts  serve  as  placeholders  for  any  three  independent  applications  contending  for  the 
processor  and  a  shared  data  structure.  '.In  our  comparative  concurrency  seminar, 
students  must  implement  the  sort  race  in  .the  five  different  languages,  starting  from 
modules  like  sort  subroutines,  terminal  drivers,  process  managers,  etc.,  supplied  by  the 
teacher.  ^ ^  ^  _ 

Machine-readable  copies  of  these  programs  are  available  from  the  Software  Engineering 
Institute.  You  may  request  a  copy  in  either  of  the  ways  described  below.  Be  sure  to 
specify  that  you  want  the  “Examples  of  Concurrent  Programs”  from  support  materials 
package  SEI-SM-25. 

1.  Electronic  Mail.  Send  yOur  request  to  education@sei.cmu.edu  on  the  Internet. 
The  programs  will  be  sent  by  electronic  mail  within  a  few  days. 

2.  Diskette.  A  diskette  containing  the  programs  may  be  ordered  from  the  SEI 
Software  Engineering  Curriculum  Project.  The  cost  is  $10  and  a  check  must 


^Dijkstra,  E.  W.  “Hierarchical  Ordering  of  Sequential  Processes.”  Acta  Informatica  1,  115-138. 
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accompany  your  order.  Two  formats  are  available:  IBM  PC/AT  diskette  (5.25”, 
double-sided,  high-density,  1.2M  byte)  and  Macintosh  diskette  (3.5”,  double-sided, 
800K  byte).  Please  specify  the  desired  format. 
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Dining  Philosophers  in  Ada 


—  Dining  Philosophers  in  Ada 

—  Michael  B.  Feldman,  The  George  Washington  University 

—  January  1990 


with  TEXT_I0,  CALENDAR; 
use  CALENDAR; 
procedure  EAT  is 

package  INT_I0  is  new  TEXT_I0. 1 NTEGER_I0 (INTEGER)  ; 
task  type  CHOPSTICK  is 
entry  PICKUP; 
entry  PUTDOWN; 
end  CHOPSTICK; 
task  SCREEN  is 

entry  PUT_LINE(S:  STRING); 
end  SCREEN; 

subtype  NAME  is  STRING ( 1 3) ; 
task  type  PHILOSOPHER  is 

entry  GIVE_BIRTH  <  ID:  NAME;  who,  one,  two  :  integer  ); 
end  PHILOSOPHER; 

CHOPSTICKS  :  array  (1..5)  of  CHOPSTICK; 

PHILOSOPHERS  :  array  (1..5)  of  PHILOSOPHER; 

NAMES  5  constant  array(1..5)  of  NAME 
("Tony  Hoare  ", 

"Nicky  Wirth  ", 

"Eddy  Dijkstra", 

"Jean  Ichbiah  ", 

"Narain  Gehani"); 

NO_MEALS  :  integer; 

START_TIME:  duration; 

task  body  SCREEN  is 
begin 
loop 
select 

accept  PUT_LINE(S:  STRING)  do 
TEXT_IO.PUT_LINE(S) ; 

end  PDT_LINE; 
or 

terminate; 
end  select; 
end  loop; 
end  SCREEN; 

task  body  CHOPSTICK  is 
begin 
loop 
select 

accept  PICKUP; 
or 

terminate; 
end  select; 

accept  PUTDOWN; 
end  loop; 
end  CHOPSTICK; 

task  body  PHILOSOPHER  is 
MY  NAME  :  NAME; 
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first, second, identity  :  integer; 
begin 
select 

accept  GIVE_BIRTH  (  ID:  NAME;  who,  one,  two  :  integer  )  do 
MY_NAME  ID; 

identity  who; 
first  one; 

second  two; 

SCREEN. put_line{"T  -  *• 

&  integer' image (integer (seconds (clock) -START_TIME) ) 
S  "  "  S  MY_NAME  &  "  living  and  breathing"); 
end  GIVE_BIRTH; 
or 

terminate ; 
end  select; 

for  X  in  l..NO_MEALS  loop 
CHOPSTICKS (first) .PICKUP; 

CHOPSTICKS (second) .PICKUP; 

SCREEN. put_line;"T  -  " 

S  integer ' image  (integer (seconds (clock) -START_TIME) ) 
S  "  “  S  MY_NAME  4  "  eating  with  chopsticks" 

4  integer 'image (first)  4  "  "4integer' image (second) 
delay  DURATION (2*identity) ; 

SCREEN. put_line("T  -  “ 

4  integer ' image  (integer (seconds (clock) -START_TIME) ) 
4  "  "  4  MY_NAME  4  "  done"); 

CHOPSTICKS (first) .PUTDOWN; 

CHOPSTICKS (second) .PUTDOWN; 
end  loop; 

SCREEN. put_line(MY_NAME  4  "  burp"); 
end  PHILOSOPHER; 


begin 

SCREEN. put_line ("How  many  meals  do  you  want  to  eat?"); 
I NT_I 0 . getTNO_MEALS ) ; 

TEXT_IO . NEW_LINE; 

START_TIME  seconds (clock) ; 

PHILOSOPHERS (2)  .GIVE  BIRTH (NAMES (2) , 2, 2, 3)  ; 
PHILOSOPHERS (5) .GIVE~BIRTH (NAMES (5)  ,  5, 1 , 5)  ; 
PHILOSOPHERS (3) .GIVe“bIRTH (NAMES (3) , 3, 3, 4)  ; 
PHILOSOPHERS ( 4 )  . GIVE_BIRTH (NAMES ( 4 )  ,  4 , 4 , 5 )  ; 
PHILOSOPHERS (1) .GIVE_BIRTH (NAMES (1)  ,1,1,2); 
end  EAT; 
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Dining  Philosophers  in  Concurrent  C 


/*  Non-deadlocking  Dining  Philosophers  in  Concurrent  C 
/*  Adapted  from 

Gehani  and  Roome,  "The  Concurrent  C  Programming  Language"  by 

Prof.  Michael  Feldman 

The  George  Washington  University 

February  1990 


process  spec  fork() 

{ 

trans  void  pickUpO,  putDownO; 

}; 

process  body  fork() 

( 

for  (;;)  { 

accept  pickUpO; 
accept  putDownO; 

} 

} 


process  spec  philosopher (int  id, 

process  fork  left, 
process  fork  right); 

♦define  LIMIT  10 

process  body  philosopher (id,  left,  right) 

{■ 

int  nmeal; 

printf  ("Phil .  %d;  *alive*\n",  id); 
for  (nmeal  -  0;  nmeal  <  LIMIT;  nmeal++)  ( 
/♦think;  then  enter  dining  room  */ 
delay  2* (5-id); 

/♦pick  up  forks^/ 
right . pickUp  ( ) ; 
left.pickUp  0 ; 

/♦eat^/ 

printf ("Phil .  %d:  *eating*\n",  id); 
delay  2* (5-id); 

printf ("Phil .  %d:  ♦burp*\n",  id); 

/♦put  down  forks*/ 
left . putDown ( ) ; 
right .putDown () ; 

/♦get  up  and  leave  dining  room*/ 

) 

printf  ("Phil .  %d:  That's  all,  folks!\n",  id) ; 


main () 

{ 

process  fork  f[51;  int  j; 

/♦create  forks,  then  create  philosophers*/ 
for  (j  -  0;  j  <  5;  j++) 
f[j]  “  create  fork(); 
for  (j  -  0;  j  <  5;  j++) 

create  philosopher (j,  f[jj,  f((j+l)  %  5]); 
create  philosopher (4,  fCO],  fC4)); 
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Dining  Philosophers  in  Co-Pascal 


program  diners  (input,  output); 

{  This  is  the  Dining  Philosophers  written  in  Co-Pascal  } 

{  Prof.  Michael  B.  Feldman,  The  George  Washington  University  } 
{  January  1990  } 

const  life  -  5; 
type  semaphore  -  integer; 
var  chopsticks:  array[0..3]  of  semaphore; 
room:  semaphore; 
screen :  semaphore; 
which:  integer; 

procedure  delay (HowLong:  integer); 

var  count:  integer; 
begin 

count  : -  1 ; 

while  count  <  HowLong  do 
count  :-  count+1; 
end  (delay); 


procedure  think (WhoAmI :  integer); 
begin 

wait (screen) ; 

writeln ( 'Philosopher  ', WhoAmI: 2,'  ..Hmmm...’); 
signal (screen) ; 
delay (10* (WhoAmI+1) ) ; 

end  (think); 

procedure  eat (WhoAmI:  integer;  meals: integer)  ; 
begin 

wait (screen) ; 

writeln ( 'Philosopher  ', WhoAmI: 2,'  eating  meal  ',  meals; 3,  '  ..Slurp  slurp...'); 

signal (screen) ; 

delay (100* (WhoAml+l) ) ; 

end  ( eat ) ; 

procedure  philosopher (WhoAmI :  integer); 

var  meals:  integer; 
begin 

wait  (-screen)  ; 

writeln ( 'philosopher  ', WhoAmI: 2,  '  breathing’); 
signal  (screen) ; 

for  meals  :-  1  to  life  do 
begin 

think (WhoAmI) ; 
wait (room) ; 

wait (chopsticks [WhoAmI] ) ; 
wait (chopsticks [ (WhoAmI -H)  mod  4]); 
eat (WhoAmI, meals) ; 
signal (chopsticks [WhoAmI] ) ; 
signal  (chopsticks [ (WhoAmI -H)  mod  4]); 
signal (room) ; 
end; 
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wait (screen) ; 

writeln (' philosopher  ',WhoAmI:2, 
signal (screen) ; 

end  (philosopher); 


begin  (main) 
room  3; 
screen  1; 
for  which  0  to  3  do 
chopsticks r which]  :•  1; 
cobegin 

philosopher (0) ; 
philosopher (1) ; 
philosopher (2) ; 
philosopher  (3) ; 
coend; 


end 


(diners } . 


'  burp* )  ; 
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Dining  Philosophers  in  occam 


—  Implementation  in  occam  of  the  dining  philosophers  problem. 

—  Distributed  with  University  of  Loughborough  occam  for  UNIX  systems. 

—  execute  with  -c  option  to  get  cursor  control 

—  A  number  of  philosophers  spend  their  life  either  thinking  or  eating. 

—  Unfortunately  there  is  only  one  bowl  of  spaghetti  and  there  is  only  one  fork 

—  per  philosopher,  but  two  forks  are  needed  to  eat  the  food. 

—  A  philosopher  waits  for  a  neighbour  to  relinquish  a  fork  if  needed. 

--  The  system  can  deadlock  (the  philosophers  can  starve)  but  it  is  difficult 

—  to  prove  it . 

—  The  system  is  simulated  by  making  the  philosophers  eat  and  think  for  random 
--  times,  a  cursor  addressible  screen  is  used  for  output  showing  the  current 

—  status. 


DEF  Enter  -  0,Exit  -  1  : 

DEF  Grab  -  0, Replace  -  1, To. Right  -  2, To. Left  -  3  : 
DEF  Grabbed  •«  0,PutBack  =  1  : 

DEF  Thought  -  0, Consume  -  1, Queuing  -  2  : 


--  Number  of  philosophers  -  may  be  between  1  and  8 


DEF  number. of .philosophers  -  5: 

CHAN  Door  [number .of . philosophers ], Request .Fork  [number .of .philosophers*2 1  : 

CHAN  phil.info  [number. of .philosophers] , Fork. info  [number .of .philosophers]  : 
CHAN  room. info  : 

EXTERNAL  PROC  random  (VALUE  m,VAR  n)  : 


—  Sit  and  think  outside  the  room  for  a  random  time  interval 


PROC  Think  (VALUE  n)  - 
VAR  think. time  : 

SEQ 

—  Thinking 

phil.info  [n]  !  Thought 

random  (90, think. time) 

WAIT  40  +  think. time 

—  Finished  thinking  -  now  waiting  to  eat. 
phil.info  [n]  !  Queuing  ; 


—  Have  grabbed  two  forks  -  signal  eating  and  wait  for  a  random  interval 


PROC  Eat  (VALUE  n)  - 
VAR  eat. time  : 

SEQ 

phil.info  [n]  !  Consume 
random  (80, eat . time) 

WAIT  50  +  eat. time 

—  Define  action  of  philosopher  -  think, enter  room, pick  up  left  then 

—  pick  up  right  fork  and  eat,  finally  leave  the  room  to  think  again. 


PROC  Philosopher  (VALUE  n, 
WHILE  TRUE 
SEQ 

Think  (n) 

Door  [n]  !  Enter 

left  !  Grabbed 
right  !  Grabbed 


CHAN  left, right)  “ 
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Eat  (n) 

left  !  PutBack 
right  !  PutBack 
Door  [n]  !  Exit  : 

—  Room  -  keep  account  of  how  many  philosophers 

—  there  are  eating  or  waiting  to  eat. 

PROC  Room  “ 

VAR  action, number. in  : 

SEQ 

number. in  0 
WHILE  TRDE 
SEQ 

room. info  !  number. in 

ALT  m  «  [0  FOR  number .of .philosophers] 

Door  [m]  ?  Action 
IF 

Action  -  Enter 

number. in  number. in  +  1 

TRUE 

number. in  number. in  -  1  : 

—  Control  of  each  fork  -  can  be  picked  up  by  either  side  but  then  must 

—  wait  until  it  is  put  down. 

—  Tell  the  display  process  the  new  status  of  the  fork. 

PROC  Fork  (VALUE  n.CHAN  left, right)  - 
WHILE  TRUE 
ALT 

left  ?  ANY 
SEQ 

Fork. Info  [n]  !  To. Left  ;  Grab 
left  ?  ANY 

Fork. Info  [n]  !  To. Left  ;  Replace 
right  ?  ANY 
SEQ 

Fork. Info  [n]  !  To. Right  ;  Grab 
right  ?  ANY 

Fork, Info  [n]  !  To. Right  ;  Replace  : 

—  Show  animated  display  of  what  is  happening 

EXTERNAL  PROC  str . to . screen  (VALUE  s  ())  : 

EXTERNAL  PROC  num. to. screen . f  (VALUE  n,f)  : 

EXTERNAL  PROC  Goto.x.y  (VALUE  x,y)  : 

EXTERNAL  PROC  clear. screen  : 

PROC  Display  «• 

VAR  Action, Which, Person, How .Many . In  : 

SEQ 

clear. screen 
Goto.x.y  (0,2) 

str .to. screen  ("Number  of  philosophers  in  room  :  ") 

SEQ  n  “  [0  FOR  number. of .philosophers] 

SEQ 

Goto.x.y  (0,(n*3)+4) 

str .to . screen  ("Philosopher  ") 

num. to. screen . f  (n,3) 

WHILE  TRUE 
ALT 

room. info  ?  How. Many. In 
SEQ 

Goto.x.y  (33,2) 

num. to. screen. f  (How.Many.In, 2) 
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ALT  m  -  [0  FOR  number . of . philosophers ] 

ALT 

phil.info  [m]  ?  Action 
IF 

Action  “  Thought 
SEQ 

Goto.x.y  (20, (m*3)+4) 

str .to. screen  ("Thinking  ") 

Action  «  Queuing 
SEQ 

Goto.x.y  (20,(m*3)+4) 

str .to. screen  ("Waiting  ") 

TRUE 

SEQ 

Goto.x.y  (20, (m*3)+4) 

str .to. screen  ("Eating  ") 

Fork. Info  [m]  ?  Which 
SEQ 
IF 

Which  “  To. Left 
SEQ 

Person  m 

Goto.x.y  (50,  (Per3on*3) +4) 

TRUE 

SEQ 

Person  (m+1) \number. of -philosophers 

Goto.x.y  (55, (Person*3) +4) 

Fork. Info  [m]  ?  Action 
IF 

Action  “  Grab 

str .to. screen  ("!") 

Action  -  Replace 

str .to. screen  ("  ")  : 

—  Define  parallel  processes 

—  There  are  two  channels  from  philosophers  to  each  fork. 

—  The  fork  process  ensures  it  is  in  the  hand  of  one  philosopher  only. 


PAR 

Room 

Display 

PAR  n  -  [0  FOR  number .of . philosophers J 
PAR 

Philosopher  (n, Request. Fork  [n*2) , Request .Fork  [(n*2)+l)) 
Fork  (n, Request .Fork  [ (n*2) +1) , Request. Fork 
[ ( (n*2) +2) \ (number . of .philosophers*2)  ) ) 
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Sorting  Algorithm  Race  in  Ada 


WITH  TEXT_IO;  USE  TEXT_IO; 

WITH  VTIOO;  USE  VTIOO;  —  this  package  is  shown  after  the  main  program 
PROCEDURE  SortRace  IS 


SortRace  in  Ada 

F.  C.  Hathorn 
CS  -  358 
5/6/87 


PACKAGE  Int_IO  IS  NEW  Integer_IO (Integer) ; 

MaxLimit:  CONSTANT  :=  34; 

Linel:  CONSTANT  8; 

Line2:  CONSTANT  :=  12; 

Line3:  CONSTANT  16; 

SUBTYPE  ValueType  IS  CHARACTER; 

TYPE  Vector  IS  ARRAY  (0 .. MaxLimit >  OF  ValueType; 

V:  Vector; 

Limit:  Integer; 

TASK  Bubble_Sort  is 
ENTRY  GoAhead; 

END  Bubble_Sort; 

TASK  Insert  Sort  is 
ENTRY  GoAhead; 

END  Insert_Sort; 

TASK  Heap_Sort  is 
ENTRY  GoAhead; 

END  Heap_Sort; 

TASK  Screen  is 

Entry  ClearScreen; 

Entry  Put At (column,  row:  INTEGER;  c:  ValueType); 
END  Screen; 


—  Put  Vector 

—  This  procedure  displays  a  vector  on  the  screen  at  a  given  row 


PROCEDURE  PutVect(S:  Vector;  Row:  INTEGER)  IS 
BEGIN 

FOR  i  IN  1 . . Limit  LOOP 

Screen .PutAt (i+1 , Row, S  (i) ) ; 

END  LOOP; 

END  PutVect; 


—  Swap 

—  This  procedure  exchanges  two  integer  variable  values . 
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PROCEDURE  Swap(x,y:  IN  OUT  ValueType;  i,j,  row:  INTEGER)  IS 
Temp:  ValueType; 

BEGIN 

Temp  : -  x; 

X  :-  y; 
y  :-  Temp; 

Screen. PutAt (i+l, row,x) ; 

Screen. Put At (j+l,row,y) ; 

END  Swap; 


—  Task  Screen 

—  Code  to  write  to  the  screen.  Two  entries  are  provided,  ClearScreen 

—  which  clears  the  screen  and  PutAt  which  writes  one  character. 


TASK  BODY  Screen  IS 

BEGIN 

LOOP 

SELECT 

ACCEPT  ClearScreen  DO 
VTIOO .ClearScreen; 

END  ClearScreen; 

OR 

ACCEPT  PutAt (column,  row:  INTEGER;  c:  ValueType)  DO 
VTIOO. SetCursorAt (column, row) ;  put (c) ; 

END  PutAt; 

OR 

TERMINATE; 

END  SELECT; 

END  LOOP; 

END  Screen; 


—  Task  Bubble  Sort 

—  Code  provided  by  Professor  M.B.  Feldman  and  modified  slightly  to  sort 

—  from  1.. Limit  rather  than  0.. Limit. 


TASK  BODY  Bubble_Sort  IS 
MyV:  Vector; 

MyRow:  Integer  :»  Linel; 

CurrentBottom:  INTEGER; 

AnotherPassNeeded:  BOOLEAN; 

Top:  INTEGER; 

BEGIN  — Bubble_Sort 

Accept  GoAhead; 

PutVect (V, MyRow) ; 

MyV  :-  V; 

Top  :-  1; 

CurrentBottom  :-  Limit; 

AnotherPassNeeded  TRUE; 

WHILE  AnotherPassNeeded  AND  (CurrentBottom  >  1)  LOOP 
AnotherPassNeeded  :-  FALSE; 

FOR  Current  IN  Top  . .  CurrentBottom-1  LOOP 
IF  (MyV(Current+l)  <  MyV (Current) )  THEN 
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Swap (MyV (Current+1) ,MyV (Current) , Current+1 , Current, MyRow) ; 
AnotherPassNeeded  TRUE; 

END  IF; 

if  (current+1  =  currentbottom)  THEN 

Screen. PutAt (CurrentBottom+1,  MyRow+1, 

END  IF; 

END  LOOP; 

CurrentBottom  CurrentBottom  -  1; 

END  LOOP; 

Screen. Put At (CurrentBottom+1,  MyRow+1,  ' * ' )  ; 

END  Bubble  Sort; 


—  Taajc  Insertion  Sort 

—  This  task  performs  an  insertion  sort  on  the  input  array. 


TASK  BODY  Insert_Sort  IS 
MyV:  Vector; 

MyRow:  Integer  Line2; 

j :  integer;  — pointer  into  sorted  array 

insert:  valuetype;  — current  key  being  inserted 

begin  — Insert_Sort 
Accept  GoAhead; 

PutVect (V;  MyRow) ; 

•  MyV  V; 

MyV(Limit+l)  :-  'z';  — initialize  last  +  1th  element 

Screen. PutAt (Limit+1,  MyRow+1,  '<*);  — mark  last  element  as  sorted 

FOR  i  IN  REVERSE  1.. Limit-1  LOOP  — insert  elements  limit-1.. 1  into 
insert  MyV(i);  — save  current  key 

j  :-  i  +  1; 

WHILE  (insert  >  MyV(j))  LOOP  — shift  larger  keys  up 

MyV(j-l)  :-  MyV(j); 

Screen . PutAt ( j ,  MyRow,  MyV ( j ) ) ; 
j  j  +  1; 

END  LOOP; 

MyV(j-l)  :•  insert;  — insert  current  key  in  proper  place 

Screen.PutAt ( j,  MyRow,  insert); 

Screen. Put At (i+1,  MyRow+1,  '<’); 

END  LOOP; 

Screen.PutAt (2,  MyRow+1,  '*'); 
end  Insert  Sort; 


—  Task  Heap  Sort 

—  This  task  sorts  the  input  key  array  using  the  heap  sort  algorithm. 

—  The  input  array  is  treated  as  a  binary  tree  when  building  the  heap. 


TASK  BODY  Heap_Sort  IS 
MyV:  Vector; 

MyRow:  Integer  Line3; 

Procedure  Adjust (t:  IN  ODT  Vector;  root,  Lmt:  integer)  IS 

—  adjust  is  used  to  adjust  a  heap  whose  left  and  right  trees  are  heaps,  but 

—  whose  root  may  be  smaller  than  its  left  or  right  child 

j :  integer;  — child  pointer 
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key:  ValueType;  — key  element 

done:  boolean  :-  FALSE;  — adjustments  done  flag 

BEGIN 

key  :-  t(root);  — save  root  key 

j  :«  2  *  root;  — calculate  child  pointer 

WHILE  ((j  <-  Lmt)  and  not  done)  LOOP 

IF  (j  <  Lmt)  THEN  —find  largest  child 

if  (t(j)  <  t(j+l))  THEN  j  j  +  1;  END  IF; 

END  IF; 

IF  (key  >-  t(j))  THEN 

done  :-  TRUE;  — done  if  child  smaller  than  root 

ELSE  — otherwise  move  child  up 

t(j  /  2)  :-  t(j); 

Screen. Put At (j  /  2  +  1,  MyRow,  t(j)); 
j  :-  2  *  j; 

END  IF; 

END  LOOP; 

t(j  /  2)  :-  key;  — insert  root  in  correct  position 

Screen. PutAt (j  /  2  +  1,  MyRow,  key) ; 

END  Adjust; 

BEGIN 

—  main  section  of  code  for  heap  sort 
Accept  GoAhead; 

PutVect (V,  MyRow) ; 

MyV  :-  V; 

— convert  the  input  array  into  a  heap 
FOR  i  IN  REVERSE  1.. (Limit  /  2)  LOOP 
adjust (MyV,  i.  Limit); 

END  LOOP; 

FOR  i  IN  REVERSE  1.. (Limit-1)  LOOP  — pick  off  first  element  n-1  times 

swap (MyV (1),  MyV(i+l),  1,  i+1,  MyRow);  — swap  with  last  element 

Screen. PutAt (i+2,  MyRow+1,  '<•); 

adjust (MyV,  1,  i);  — readjust  heap  less  last  element 

END  LOOP; 

Screen . PutAt (2 ,  MyRow+1 ,  ' *  ' )  ; 

END  Heap_sort; 


BEGIN 

V  "  ZzYyXxWwVvUuTtSsRrQqPpOoNnMmLlKkJj”; 
V(0)  •<’; 

V(34)  :-  '<'; 

Screen .ClearScreen; 

Screen. Put At (1,  Linel-3,  '  '); 

Put_Line ("SORT  RACE  -  in  Ada") ; 

Put ("Enter  Number  of  Keys  to  Sort  (3-33):  ") ; 
lnt_IO.Get (Limit) ; 

IF  (Limit  <  3)  OR  (Limit  >  33)  THEN 
Limit  10; 

Put (ASCII. BEL); 

Put_Line ("Sorting  10  keys"); 

END  IF; 

Screen .PutAt (1 ,  Linel-1,  '  ’); 

Put_Line ("Bubble  Sort"); 

Screen.PutAt (1,  Line2-1,  '  '); 

Put_Line ("Reverse  Insertion  Sort"); 
Screen.PutAt (1,  Line3-1,  '  '); 

Put_Line ("Heap  Sort" ) ; 

Screen.PutAt (1,20,  '  '); 

Bubble_Sort . GoAhead; 

Insert_Sort . GoAhead; 

Heap_Sort . GoAhead; 

END  SortRace; 
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with  TEXT_IO,  MY_INT_IO;  use  TEXT_IO,  MY_INT_IO; 
package  VTIOO  is 
use  ASCII; 


—  Procedures  for  drawing  pictures  of  the  solution  on  VDU. 

—  ClearScreen  and  SetCursorAt  are  device-specific 


SCREEN_DEPTH  :  constant  INTEGER  24; 

SCREEN_WIDTH  :  constant  INTEGER  80; 

subtype  DEPTH  is  INTEGER  range  1 . .SCREEN_DEPTH; 
subtype  WIDTH  is  INTEGER  range  1 . . SCREEN_WIDTH; 


procedure  ClearScreen; 

procedure  SetCursorAt (  A:  WIDTH;  D  :  DEPTH) ; 
end  VTIOO; 


with  TEXT_IO;  use  TEXT_IO; 
pa.ckage  body  VTIOO  is 
use  ASCII; 


—  Procedures  for  drawing  pictures  on  VTIOO 

—  ClearScreen  and  SetCursorAt  are  trminal-specif ic 


procedure  ClearScreen  is 
begin 

PUT(  ESC  «  ”t2J"  ); 
end  ClearScreen; 

procedure  SetCursorAt (A:  WIDTH;  D  :  DEPTH)  is 
begin 

PUT  (  ESC  &  " [ "  ) ; 

PDT(  D,  1  ); 

PUT (  ' ; •  ) ; 

PUT<  A,  1  ); 

PUT (  ' f •  )  ; 
end  SetCursorAt; 

end  VTIOO; 
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Sorting  Algorithm  Race  in  Concurrent  C 


SortRace  in  Concurrent  C 


F .  C .  Hathorn 
CS  -  358 
5/5/87 


*/ 

tdefine 

MaxLimit 

36 

fdefine 

Linel 

6 

tdefine 

Line2 

12 

tdefine 

Line3 

18 

tdefine 

SMILE 

•<• 

tdefine 

STAR 

•  *  t 

tdefine 

BELL 

•\7’ 

tdefine 

VALUETYPE 

char 

tdefine 

TRUE 

1 

tdefine 

FALSE 

0 

VALUETYPE 

int 

int 


VfMaxLimit]  -  "  ZzYyXxWwVvUuTtSsRrQqPpOoNnMmLlKlcJj " ; 
Counter  -  0; 

Limit; 


process  spec 
process  spec 
process  spec 
process  spec 


Bubble_Sort (  VALUETYPE  MyV[36),  int  MyRow,  process  Scrn  ); 

Insort_Sort (  VALUETYPE  MyV[36],  int  MyRow,  process  Scrn  ) ; 

Heap_Sort  (  VALUETYPE  MyV{36),  int  MyRow,  process  Scrn  ) ; 

Scrn  () 

{ 

trans  void  PutAt(int,  int,  VALUETYPE); 
tr2ms  void  CheckWinner (int) ; 

); 


/* - 

—  Bubble  Sort 

—  Code  Provided  by  Professor  M.B.  Feldman  and  modified  slightly  to  sort 

—  from  1.. Limit  rather  than  0.. Limit. 

- */ 

process  body  Bubble_Sort (MyV,  MyRow,  Screen) 

{ 

int  CurrentBottom; 
int  AnotherPassNeeded; 
int  Current,  Top; 

PutVect (MyV, MyRow, Screen) ; 

Top  -  1; 

CurrentBottom  -  Limit; 

AnotherPassNeeded  -  TRUE; 

while  ((AnotherPassNeeded)  (CurrentBottom  >1))  { 

AnotherPassNeeded  •  FALSE; 

for  (Current  -  Top;  Current  <  CurrentBottom;  Current++)  { 
if  (MyV[Current+l]  <  MyV[Currentl )  { 

Swap  ( (MyV [Current-t-1  ] ,  SMyV [Current  ] ,  Current+1,  Current,  MyRow, 
Screen) ; 

AnotherPassNeeded  •  TRUE; 

) 

if  (Current+1  --  CurrentBottom) 

Screen. PutAt (CurrentBottom+1,  MyRow+1,  SMILE); 
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CurrentBottom  -  CurrentBottom  -  1; 

) 

Screen. Put At (CurrentBottom+1,  MyRow+1,  STAR) ; 

Screen .CheckWinner (MyRow  +  1); 

)  /*  Bubble_Sort  */ 

/* - 

—  Inseirtion  Sort 

—  This  process  performs  an  insertion  sort  on  the  input  array. 


process  body  Insert_Sort (MyV,  MyRow,  Screen) 

{ 


-  */ 


int  j;  /*  pointer  into  sorted  array  */ 

int  i  ; 

VALUETYPE  insert;  /*  current  key  being  inserted  */ 


PutVect (MyV,  MyRow,  Screen); 
MyV[Limit+l]  -  '\177'; 

Screen. PutAt (Limit+1,  MyRow+1, 
for  (i-Limit-1;  i>-l;  i — )  { 
insert  -  MyV[i]; 


/‘initialize  last  +  1  element  */ 
SMILE) ;  /‘mark  last  element  as  sorted 
/‘insert  elements  from  limit-1.. 1  ‘/ 
/‘save  current  key  ‘/ 


j  -  i  +  1; 

while  (insert  >  MyV[j])  {  /‘shift  larger  keys  up  ‘/ 

MyV[j-l]  -  MyV[j] ; 

Screen.PutAt ( j,  MyRow,  MyV[jl); 

j  “  j  +  1; 


MyV(j-l]  -  insert;  /‘ins  current  key  in  proper  loc  »/ 

Screen .PutAt (j ,  MyRow,  insert); 

Screen .PutAt (i+1 ,  MyRow+1,  SMILE) ; 

) 

Screen .PutAt (2 ,  MyRow+1,  STAR); 

Screen. CheckWinner (MyRow  +1); 

}  /*  Insert  Sort  ‘/ 


*/ 


/* - 

—  Heap  Sort 

—  This  process  sorts  the  input  key  array  using  the  heap  sort  algorithm. 

—  The  input  array  is  treated  as  a  binary  tree  when  building  the  heap. 
- */ 

process  body  Heap_Sort (MyV,  MyRow,  Screen) 

{ 

int  i  ; 

PutVect (MyV,  MyRow,  Screen) ; 

/‘  convert  the  input  array  into  a  heap  ‘/ 
for  (i-(Limit  /  2);  i>-l;  i — ) 

Adjust (MyV,  i.  Limit,  MyRow,  Screen); 

/‘  pick  off  first  element  n-1  times  ‘/ 
for  (i- (Limit-1) ;  i>-l;  i — )  ( 

Swap(SMyV[l] ,  SMyV(i+l],  1,  i+1,  MyRow, 

Screen);  /‘  swap  w/  last  element  ‘/ 

Screen .PutAt (i+2 ,  MyRow+1,  SMILE); 

Adjust (MyV,  1,  i,  MyRow,  Screen);  /*  readjust  heap  ‘/ 

) 

Screen.PutAt (2,  MyRow+1,  STAR); 

Screen. CheckWinner (MyRow  +  1); 

)  /‘  Heap_sort  ‘/ 


/* - 

—  Process  Screen 

—  This  process  controls  access  to  the  screen  for  writing  once  the  sort 
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processes  have  been  activated 


process  body  Scrn() 

{ 

for  (;;)  /*  loop  forever  */ 

select 
{ 

accept  PutAt (column,  row,  c) 

{ 

SetCursorAt (column,  row) ; 
putchar (c) ; 

)  /*  PutAt  */ 
or 

accept  CheckWinner (row) 

( 

int  i; 

Counter  -  Counter  +  1; 

SetCursorAt (Limit+4 ,  row) ; 
switch  (Counter)  { 

case  1:  printf ("WINNER! !!") ; 
break; 

case  2:  printf ("SECOND !!")  ; 
break; 

case  3:  printf ("THIRD! ")  ; 

SetCursorAt ( 1 ,  Line3+4 ) ; 
break; 

} 

for  (i-Counter;  i  <  4;  i++)  putchar (BELL)  ; 
}  /*  CheckWinner  */ 
or 

terminate; 

} 

)  /*  Scm  */ 


main  () 

{ 

VALUETYPE  vl [MaxLimit] ,  v2 [MaxLimit] ,  v3(MaxLimit) 
int  i  ; 


process  Scrn  monitor;  /*  screen  monitor  */ 

process  Bubble_Sort  si; 
process  Insert_Sort  s2; 
process  Heap_Sort  s3; 

ClearScreen { ) ,  SetCursorAt ( ) ; 

V[0]  -  '\0'; 

for  (i“0;  KMaxLimit;  i++) 

{vl[i)  -  V[i];  v2[i]  -V[il;  v3[i)  -V[i];  ) 

SetCursorAt (1,1); 

ClearScreen ( ) ; 

printf ("SORT  RACE  -  in  Concurrent  C\n"); 
printf ("Enter  Number  of  Keys  to  Sort  (3-33);  "); 
scanf ("%d%*c",  (Limit); 
if  ((Limit  <  3)  ||  (Limit  >33))  { 

Limit  -  10; 
putchar (BELL) ; 

printf ("Sorting  only  10  Keys\n"); 

} 

SetCursorAt (2,  Linel-2) ; 
printf ("Bubble  Sort" ) ; 

SetCursorAt (2,  Line2-2); 
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printf ("Reverse  Insertion  Sort"); 
SetCursorAt (2,  Line3-2, ) ; 
printf ("Heap  Sort"); 


/*  start  the  screen  monitor  first  */ 
monitor  -  create  Scrn(); 

/*  start  the  3  sort  processes  */ 

si  -  create  Bubble_Sort (vl ,  Linel,  monitor); 
s2  «  create  Insert_Sort (v2,  Line2,  monitor); 
33  -  create  Heap_Sort (v3,  Line3,  monitor); 

}  /*  main  */ 


ClearScreen  () 

{ 

putchar ( ' \033 ' ) ;  putchar  ( ' [ ' ) ; 
putchar ( ' 2 ' ) ;  putchar ( ' J ' ) ; 

}  /*  clearscreen  •/ 

SetCursorAt (column,  row) 
int  column,  row; 

{ 

static  ASCIIOffset  -  48; 
putchar ( ' \033 ' ) ;  putchar (*('); 


putchar ( (row 

/ 

10) 

+ 

ASCIIOffset) ; 

putchar ( (row 

% 

10) 

+ 

ASCIIOffset) ; 

putchar (';');  ■ 
putchar ( (column 

/ 

10) 

+ 

ASCIIOffset) ; 

putchar ( (column 

% 

10) 

+ 

ASCIIOffset) ; 

putchar ( 'H' ) ; 

)  /*  SetCursorAt  */ 


/* - 

—  Put  Vector 

—  This  procedure  copies  the  input  vector  into  a  local  vector  of  the 

—  calling  task  and  displays  that  vector  on  the  screen 
- */ 

PutVect(InV,  row.  Screen) 

VALUETYPE  InV[l; 
int  row; 

process  Scrn  Screen; 

{ 

int  i; 

for  (i  -  1;  i  <-  Limit;  i++)  Screen .PutAt (i+1 , row, InV(i) ) ; 

}  /*  PutVect  */ 


/* - 

—  Swap 

—  This  procedure  exchanges  two  integer  variable  values . 


- */ 

Swap(x,  y,  i,  j,  row.  Screen) 

VALUETYPE  *x,  *y; 
int  i,  j,  row; 
process  Scrn  Screen; 

( 

VALUETYPE  temp; 
temp  •  *x; 

*x  -  *y; 
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*y  -  temp; 

Screen.PutAt (i+1,  row,  *x)  ; 
Screen. PutAt (j+l,row, *y)  ; 
)  /*  Swap  */ 


/* - 

—  Adjust 

—  adjust  is  used  to  adjust  a  heap  whose  left  and  right  trees  are  heaps, 

—  but  whose  root  may  be  smaller  than  its  left  or  right  child 
- »/ 


Ad  j  u  St (t ,  root ,  Lmt ,  MyRow , 
VALUETYPE  t ( ]  ; 
int  root,  Ijnt,  MyRow; 
process  Scm  Screen; 

{ 

int  j; 

VALOETYPE  key; 
int  done  -  FALSE; 


Screen) 


/*  child  pointer  */ 

/*  key  element  */ 

/*  adjustments  done  flag  */ 


key  -  t[root];  /*  save  root  key  */ 

j  «  2  *  root;  /*  calculate  child  pointer  */ 

while  ((j  <-  Lmt)  &&  idone)  { 

if  (j  <  Lmt)  {  /*  find  largest  child  */ 

if  (t[j]  <  t[j+l])  j  -  j  +  1;  ) 
if  (key  >-  t[j]) 

done  -  TRUE;  /*  done  if  child  smaller  than  root  */ 

else  (  /*  otherwise  move  child  up  */ 

t[j  /  2]  -  t[j); 

Screen . PutAt ( j  /  2  +  1,  MyRow,  t[j)); 
j  -  2  *  j; 


) 

t[j  /  21  -  key;  /*  insert  root  in  correct  position  */ 

Screen .PutAt (j  /  2  +  1,  MyRow,  key); 

)  /*  Adjust  */ 
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Sorting  Algorithm  Race  in  Co*Pascal 


PROGRAM  SortRace (INPUT, OUTPUT); 

{  Sort  Race  -  written  by  Roshan  Thomas 

The  George  Washington  University 
CSci  358  -  Spring  1989 

Tested  under  Co-Pascal  version  3.0  for  IBM-PC. 

Be  sure  ANSI. SYS  is  installed  before  compiling  this. 

demonstrates  a  concurrent  sort  race  using  Bubble  Sort,  Linear  Insertion, 
and  a  non-recursive  version  of  Quicksort  } 

CONST  Limit  -  32; 

TYPE  ValueType  -  CHAR; 

semaphore  -  INTEGER; 

Vector  -  ARRAY [ 0 .. Limit  1  OF  ValueType; 


VAR  V:  Vector; 

i.  Won:  INTEGER; 

A;  CHAR; 

Screen:  semaphore; 


PROCEDURE  ClearScreen; 

BEGIN 

Write  (CHR  (27)  ) ;  Write('C); 

Write  ('2');  Write ('J') 

END  ( ClearScreen ) ; 

PROCEDURE  Set CursorAt (column,  row:  INTEGER); 

BEGIN 

WriteLn; 

Write (CHR (27) ) ;  Write (•[’) ; 

Write (row: 1) ; 

Write  (';'); 

Write (column; 1) ; 

Write  CH' )  ; 

END  (SetCursorAt); 

PROCEDURE  WriteAt (column,  row:  INTEGER;  C:  CHAR) ; 
BEGIN 

WAIT (Screen) ; 

SetCursorAt (column, row) ; 

Write (C) ; 

SIGNAL (Screen) ; 

END  (WriteAt); 

PROCEDURE  WriteVect (V;  Vector;  Row:  INTEGER); 

VAR  i:  INTEGER; 

BEGIN 

FOR  i  :-  0  TO  Limit  DO  BEGIN 
WriteAt (i+l,Row,V(i] ) ; 

END; 

WriteLn; 

END  (WriteVect); 

PROCEDURE  CopyVect (VAR  Dest:  Vector;  Source:  Vector); 


SEI-CM-25 


Examples  of  Concurrent  Programs 


21 


VAR  i:  INTEGER; 

BEGIN 

FOR  i  0  TO  Limit  DO  BEGIN 
De3t[i)  Source [i]; 

END; 

END  (CopyVect}; 

PROCEDURE  Swap (VAR  x,y:  ValueType;  i,j,  row;  INTEGER); 
VAR  Temp:  ValueType; 

BEGIN 

Temp  : -  x; 

X  y; 

y  Temp; 

WriteAt (i+1, row, x) ; 

WriteAt ( j+1, row, y) ; 

END  (Swap); 


PROCEDURE  Bubble (MyV:  Vector;  MyRow:  INTEGER); 


CurrentBottom:  INTEGER; 

AnotherPaasNeeded:  BOOLEAN; 

Top;  INTEGER; 

Current:  INTEGER; 

BEGIN 

Top  0; 

CurrentBottom  Limit; 

AnotherPasaNeeded  TRUE; 

WriteVect (MyV, MyRow) ; 

WHILE  AnotherPaasNeeded  AND  (CurrentBottom  >  0)  DO  BEGIN 
AnotherPasaNeeded  FALSE; 

FOR  Current  Top  TO  CurrentBottom-1  DO  BEGIN 
IF  MyVtCurrent+1]  <  MyV [Current)  THEN  BEGIN 

Swap (MyV [Current+1] , MyV (Current ) ,Current+l, Current, MyRow) ; 
AnotherPasaNeeded  TRUE; 

END; 

END; 

CurrentBottom  CurrentBottom  -  1; 

END; 

IF  Won  -  0  THEN 
BEGIN 

WAIT (Screen) ; 

Won  1; 

SetCursorAt (8, 6) ; 

WRITELNC BUBBLE  SORT  HAS  WON,  SURPRISINGLY'); 

SIGNAL (Screen) ; 

END; 

END  (Bubble); 


PROCEDURE  LinearInsertionSort (LV;  Vector;  Lrow:  INTEGER); 
VAR 

NewArrival:  ValueType; 

Top:  INTEGER; 

Botuom:  INTEGER; 

CurrentBottom:  INTEGER; 
current :  INTEGER; 
position:  INTEGER; 


BEGIN 
Top  :» 


0; 
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Bottom  :•  Limit; 

FOR  CurrentBottom  Top+1  TO  Bottom  DO  BEGIN 

FOR  current  CurrentBottom  DOWNTO  Top+1  DO  BEGIN 
IF  LV[ current]  <  LV[ current-1]  THEN 

Swap (LV[ current ] ,  LV[curr6nt-l] ,  current,  current-1,  Lrow) ; 
{  END;} 

END; 

END; 

IF  Won  -  0  THEN 
BEGIN 

WAIT (Screen) ; 

Won  : «  1 ; 

SetCursorAt (8, 11) ; 

WRITELN (' Linear  Insertion  Sort  Has  Won,  Interestingly'); 

SIGNAL (Screen) ; 

END; 

END; 

PROCEDORE  Quic)cSort  (QV:  Vector;  Lrow:  INTEGER); 

CONST  m  -  20; 

VAR 

i,  j,  1,  r  :  INTEGER; 

X,  w  :  ValueType; 

s  :  INTEGER; 

stac)c:  array  (1..40]  of 

RECORD  l,r:  INTEGER  END; 


BEGIN 
s  1; 

stac](Cl].  1  0;  stacli(l].  r  Limit; 

REPEAT  (take  top  request  from  stac)c} 

1  :«  stac)tts]  •  1;  r  !“  staclc(a].  r;  s  s-1; 
REPEAT  (split  QV[1J . . .QVCr] ) 
i  1; 

j  r; 

X  QV[ (1+r)  div  2] ; 

REPEAT 

WHILE  QV[i]  <  X  DO  i  i+1; 

WHILE  X  <  QV(j]  DO  j  j-l; 

IF  i  <-  j  THEN 
BEGIN 

Swap(QV(i],  QV(j],  i,  j,  Lrow) ; 
i  i+1;  j  j-1; 

END; 

DNTIL  i  >  j; 

IF  i  <  r  THEN 

BEGIN  {stac)c  request  to  sort  riglit  partition) 
s  s+1;  stacl([s].  1  i;  stack[s].  r  r; 
END; 
r  j; 

UNTIL  1  >-  r 
UNTIL  s  -  0; 

IF  Won  -  0  THEN 
BEGIN 

WAIT (Screen) ; 

Won  ; -  1 ; 

SetCursorAt (8,16) ; 

WRITELN (' Quicksort  has  WON!!!!!,  PREDICTABLY'); 
SIGNAL (Screen) ; 

END; 
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END; 
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BEGIN 


V(0]  ’Z’; 

V[l] 

■Z’; 

V 

[2] 

•Y' 

;  V[3)  'y'; 

V[41  'X'; 

V[bl 

'x' ; 

V 

[6] 

•W' 

;  Vt7]  -W; 

V[8]  'V; 

V[9] 

•V; 

V 

[10] 

•u 

•;  veil]  'u 

; 

Vtl21 

m  *  'p  * 

;  V[131 

't 

f 

V[141 

•S’;  VtlS] 

s 

V[16] 

-  'R' 

;  V[17] 

'r 

0 

V[181 

'Q*;  V[19] 

'q 

V[20] 

;  V[2ll 

'p 

0 

V[22] 

•O';  V[23] 

*  O 

V[24] 

-  'N' 

;  V[25] 

'n 

0 

V[26I 

•  ** 

•M';  V[27] 

'm 

V[281 

-  'L' 

;  V(29) 

'1 

0 

V[30] 

•K’;  V[31] 

')c 

V[32] 

-  ’J’ 

Won  0; 

Screen  :«  1; 

ClearScreen; 

SetCursorAt (10,  1) ; 

WRITELN ( • SORT  RACE ' ) ; 
SetCursorAt (8,3) ; 

WRITELN ( ' BOBBLE  SORT ' ) ; 
SetCursorAt (8, 8) ; 

WRITELN ( ' LINEAR  INSERTION • ) ; 
SetCursorAt (8,13); 

WRITELN ( • QUICKSORT ' ) ; 


FOR  i:-  0  TO  Limit  DO 
BEGIN 

SetCursorAt (i+1 , 5) ; 
Write (V[i] ) ; 
SetCursorAt (i+1, 10) ; 
Write (V[i]); 
SetCursorAt (i+1, 15) ; 
Write (V[i] ) ; 

END; 

SetCursorAt (40, 5) ; 
WRITELN; 


SetCursorAt (4,20); 

WRITELN ( • PRESS  RETURN  TWICE  TO  BEGIN  THE  RACE ’ ) ; 
READLN (A) ; 

SetCursorAt (4,20); 

WRITELN ( ’ SORT  RACE  IN  PROGRESS  '); 


cobegin 

Bubble (V,5); 

Linear InsertionSort (V, 10)  ; 
Quic)cSort  (V,  15)  ; 
coend; 

WriteAt (1, 20, '  '  ) ; 

END  (SortRace). 
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Sorting  Algorithm  Race  in  Modula-2 


MODULE  Race; 


(*  This  module  implements  a  sort  race  between  5  different  sorting  *) 
(*  algorithms.  The  5  algorithms  are  executed  (pseudo)  concurrently  and  *) 
(*  their  progress  is  displayed  on  the  screen.  This  program  requires  *) 
(*  that  the  ANSI. SYS  display  driver  be  resident  on  an  IBM  PC-type  computer.*) 
(*  Tested  using  FST  Modula-2  for  IBM-PC,  and  Karlsruhe  Modula-2  for  Sun  *) 


FROM  InOut  IMPORT  Write,  WriteString; 

FROM  vtlOO  IMPORT  ClearScreen,  SetCursorAt;  (*  this  module  is  shown  *) 

(*  after  main  program  below*) 


FROM  Process  IMPORT  DefineProcess,  (*  Adds  a  procedure  to  the  list  of  *) 

(*  processes  to  executed  concurrently*) 
Croa)c,  (*  Allows  a  process  to  )cill  itself.  *) 
GoToSleep,  (*  Will  cause  temporary  self-suspend. *) 
StartSystem,  (*  Starts  concurrent  execution.  *) 
SIGNAL,  (*  Semaphore  TYPE.  *) 
Init,  (*  Initializes  a  user  semaphore.  *) 
SEND,  (*  Signal  operation  on  semaphore.  *) 
WAIT;  (*  Wait  operation  on  sempahore.  *) 


CONST  Limit  -  51; 

TYPE  ItemType  -  CHAR; 

Vector  -  ARRAY [ 0 .. Limit ]  OF  ItemType; 

VAR  A1,A2,A3,A4,A5:  Vector; 

Screen:  SIGNAL; 

PROCEDURE  WriteAt(row,  col:  CARDINAL;  c:  CHAR) ; 
BEGIN 

WAIT (Screen) ; 

SetCursorAt (col, row) ;  Write (c) ; 

SEND (Screen) ; 

END  WriteAt; 


(*  Insertion  sort - *) 

PROCEDURE  Insertion; 

VAR  i,j:  CARDINAL; 
row:  CARDINAL; 
item:  ItemType; 
exit:  BOOLEAN; 

BEGIN 

row  : -  5 ; 

WAIT (Screen) ; 

SetCursorAt (1, row) ;  WriteString ( ' Insertion : ' ) ; 

SetCursorAt (14, row);  FOR  i:-  0  TO  HIGH(Al)  DO  Write (A1 [i] ) ;  END; 
SEND (Screen) ; 

FOR  i:-  1  TO  HIGH(Al)  DO 

item  :»  Al[i];  j:-  i;  exit:-  FALSE; 

REPEAT 
DEC(j) ; 

IF  (Al[j]  >  item)  THEN 
Al[j+1] :-  Al[ j] ; 

ELSE 

Al[j+1]:-  item;  exit:-  TRUE 
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END; 

WriteAt (row, 14+j+l,Al [ j+1] )  ; 

UNTIL  (j  -  0)  OR  (exit  -  TRUE) ; 

IF  NOT  exit  THEN 

A1[0J:-  item;  WriteAt (row, 14, A1 [0] ) 

END; 

END;  (*  FOR  i:-  1  to  HIGH()  *) 

Croa)c; 

END  Insertion; 

(»  Heap  Sort  procedure  - 

PROCEDURE  HeapSort; 

VAR  i  :  CARDINAL; 
row  :  CARDINAL; 
swap:  ItemType; 

PROCEDURE  MakeHeap (low,  high:  CARDINAL); 

VAR  j,  )c:  CARDINAL; 
exit:  BOOLEAN; 
item:  ItemType; 

BEGIN 

j:-  2*low;  item:-  A2[low]; 
exit:-  FALSE; 

WHILE  ((j  <-  high)  AND  (NOT  exit))  DO 
IF  (j  <  high)  AND  (A2[j+ll  >  A2[j)) 

THEN  j:-  j+1; 

END; 

IF  (item  >-  A2[jJ)  THEN 
exit:-  TRUE; 

ELSE 

k:~  j  DIV  2; 

A2[]cl  :-  A2[j]; 

WriteAt  (row,)c+14,A2  [)c)) ;  WriteAt  (row,  j+14,item)  ; 
j:-  2*j; 

END; 

END; 

A2[j  DIV  2] :-  item; 

END  MakeHeap; 

BEGIN 

row  : -  7 ; 

WAIT (Screen) ; 

SetCur8orAt(l,row) ;  WriteString ( 'Heap  Sort:’); 

SetCur3orAt(14,row) ;  FOR  i:-  0  TO  HIGH(A2)  DO  Write (A2 [i )) ;  END; 
SEND  (Screen) ; 

FOR  i:-  (HIGH(A2)  DIV  2)  TO  0  BY  -1  DO 
MakeHeap (i, HIGH (A2) ) ; 

END; 

FOR  i:-  HIGH(A2)  TO  1  BY  -1  DO 

swap:-  A2[0];  A2[0J:-  A2(il;  A2[i]:~  swap; 

WriteAt (row, 14,A2[01 ) ;  WriteAt {row,14+i,A2 [i] ) ; 

MakeHeap (0, i-1) ; 

END; 

Croak ; 

END  HeapSort; 

(*  Shell  sort  procedure - * 

PROCEDURE  ShellSort; 

CONST  NPASS  -  4; 

VAR  steps:  ARRAY [1 . .NPASS  1  OF  CARDINAL; 
step  :  CARDINAL; 
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i,j  :  CARDINAL; 
pass  :  CARDINAL; 
row  :  CARDINAL; 
item  :  ItemType; 
exit  :  BOOLEAN; 

BEGIN 

row  9; 

WAIT (Screen) ; 

SetCursorAt (1, row) ;  WriteString (' Shell :  '); 

SetCursorAt(14,row);  FOR  i:-  0  TO  HIGH (A3)  DO  Write (A3 (i ]) ;  END; 

SEND (Screen) ; 

(*  'steps'  contains  decreasing  increments  for  each  *) 
(*  pass.  The  last  pass  has  increment  1.  ■*) 

steps [NPASS]  :•  1; 

FOR  pass  NPASS-1  TO  1  BY  ~1  DO  steps [pass ): -  2*steps [pass+1 ] ;  END; 

FOR  pass  1  TO  NPASS  DO 
step  steps [pass]; 

(*  Do  a  straight  insertion  sort  with  'step'  as  *) 

(*  an  increment  instead  of  1 .  *) 

i:-  step; 

WHILE  i  <-  HIGH (A3)  DO  (*  Use  WHILE  instead  of  FOR  because  *) 

(*  loop  increment  is  not  a  constant.*) 
item  A3[i];  j:-  i;  exit:-  FALSE; 

LOOP 

IF  (j  <  step)  OR  exit 
THEN  EXIT; 

ELSE  DEC (j, step);  (*  exit  if  decrement  would  set  j  <  0  *) 

END; 

IF  (A3[j]  >  item) 

THEN  A3[ j+step] A3(j] 

ELSE  A3 [j+step]:-  item; 
exit:-  TRUE 

END; 

WriteAt (row, 14+ j+step, A3 (j+step] ) ; 

END;  (*  LOOP  •) 

IF  (NOT  exit)  THEN 

A3(0]:-  item;  WriteAt (row, 14, A3[0) ) 

END; 

INC (i, step) ; 

END;  (*  WHILE  i  *) 

END;  (*  FOR  pass  *) 

Croa)c; 

END  ShellSort; 


(*  Bubble  sort  procedure  - *) 

PROCEDURE  Bubble; 

VAR  i,j:  CARDINAL; 
row:  CARDINAL; 
temp:  ItemType; 

BEGIN 

row  : -  11; 

WAIT (Screen) ; 

SetCursorAt (1, row) ;  WriteString ( 'Bubble:  '); 

SetCursorAt (14 , row) ;  FOR  i:-  0  TO  HIGH(A4)  DO  Write (A4 [i ]) ;  END; 
SEND (Screen) ; 

i:-  HIGH(A4) ; 

WHILE  (i  >  0)  DO 
j:-  0; 

WHILE  (j  <  i)  DO 

IF  A4[jl  >  A4(j+1]  THEN 
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tan®):-  A4  [  j+1] ; 

A4[j+1] A4[jl; 

A4  [  j]  teit®>; 

WriteAt (row, 14+j,A4 [ j] ) ;  WriteAt (row, 14+j+l,A4 [j+l] ) ; 

END; 

j:-  j+l; 

END; 

i:-  i-1; 

END; 

Croak; 

END  Bubbla; 

(*  Marge  sort  procedure - * 

PROCEDURE  MergeSort; 

VAR 

i:  CARDINAL; 

Q:  ItemType; 

TempArray:  Vector; 

Left,  TopLeft,  Right.  TopRight,  M,  CurrentLength :  CARDINAL; 
Count,  Max:  CARDINAL; 
row  :  CARDINAL; 

BEGIN 

row  :-  13; 

WAIT (Screen) ; 

SetCursorAt ( 1 , row) ;  Wr iteStr ing ( ' MergeSort :•); 

SetCursorAt(14,row);  FOR  i:-  0  TO  HIGH(A5)  DO  Write (A5 [il ) ;  END; 
SEND (Screen) ; 

Max  HIGH (AS); 

CurrentLength  :-  1; 

WHILE  CurrentLength  <  Max  DO 
TempArray  :-  AS; 

Left  :  -  0 ; 

M  0; 

WHILE  Left<-  Max  DO 

Right  :-  Left  +  CurrentLength; 

TopLeft  : -  Right ; 

IF  TopLeft  >  Max  THEN 
TopLeft  :-  Max  +  1; 

END; 

TopRight  :-  Right  +  CurrentLength; 

IF  TopRight  >  Max  THEN 
TopRight  :-  Max  +  1; 

END; 

WHILE  (Left  <  TopLeft)  AND  (Right  <  TopRight)  DO 
IF  TempArray (Left]  <-  TempArray (Right ]  THEN 
AS(M]  :-  TempArray (Left] ; 

WriteAt (row, 14+M,AS(M] ) ; 

Left  :-  Left  +1; 

ELSE 

AS (M]  : -  TempArray (Right ] ; 

WriteAt (row, 14+M,AS(M1 )  ; 

Right  :-  Right  +  1; 

END; 

M  :-  M  +  1; 

END; 

WHILE  Left  <  TopLeft  DO 

AS(M]  :-  TempArray (Left J ; 

WriteAt (row, 14+M, AS (M] ) ; 

Left  :-  Left  +  1; 

M  :-  M  +  1; 
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VmiliE  Right  <  TopRight  DO 

A5[M]  TempArray [Right J ; 
WriteAt (row, 14+M, A5 [Ml ) ; 
Right  Right  +  1; 

M  M  +  1; 

END; 

Left  TopRight; 

ENO; 

CurrentLength  2  *  CurrentLength; 
END; 

Croak; 

END  MergeSort; 


BEGIN 

A1 "ZzYyXxWwVvOuTtSsRrQqPpOoNnMmLlKkJjliHhGgFfEeDdCcBbAa"; 
A2:-  Al;  A3:-  Al;  A4:-  Al;  A5;-  Al; 

ClearScreen; 

Init (Screen) ; 

SEND (Screen) ; 

SetCursorAt (1, 20) ;  WriteString (' Starting  sort  processes  - '); 

DefineProcess (Insertion,  1000) ; 

DefineProcess (HeapSort  ,  1000); 

DefineProcess (ShellSort,  1000); 

DefineProcess (Bubble  ,  1000); 

DefineProcess (MergeSort,  1000) ; 

SetCursorAt (1, 20) ;  WriteString ( 'Main  procedure  idle  - '); 

StartSystem; 

SetCursorAt (1, 20) ;  WriteString (' Main  procedure  ending  - *); 

END  Race. 


DEFINITION  MODULE  vtlOO; 

(*  EXPORT  QUALIFIED  ClearScreen,  SetCursorAt; 


PROCEDURE  ClearScreen; 

PROCEDURE  SetCursorAt (Column,  Row:  CARDINAL); 
END  VtlOO. 


*) 


IMPLEMENTATION  MODULE  vtlOO; 
FROM  InOut  IMPORT  Write; 
VAR  ASCI lOff set:  CARDINAL; 


PROCEDURE  ClearScreen; 

BEGIN 

Write (CHR (27) ) ;  Write(’[’); 
Write ('2');  Write ('J'); 

END  ClearScreen; 
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PROCEDURE  SetCursorAt (column,  row:  CARDINAL); 
BEGIN 

Write (CHR(13) ) ; 

Write(CHR(27)  ) ;  WriteCC); 

Write (CHR( (row  DIV  10)  +  ASCIIOffset)); 
Write (CHR( (row  MOD  10)  +  ASCIIOffset)); 
Write  (';'); 

Write (CHR( (column  DIV  10)  +  ASCIIOffset)); 
Write (CHR( (column  MOD  10)  +  ASCIIOffset)); 
Write  CH' )  ; 

END  SetCursorAt; 

BEGIN 

ASCIIOffset  ORDC'O"); 

END  vtlOO. 


L  A 
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Sorting  Algorithm  Race  in  occam 


Sort  Race  in  occam 

—  Panos  Papaioannou,  The  George  Washington  University,  1989 

EXTERNAL  PRCX:  clear. screen  : 

EXTERNAL  PROC  goto.x.y  (value  x,y)  : 

EXTERNAL  PROC  num. from. keyboard  (var  n>  : 

EXTERNAL  PROC  num. to. screen . £  (value  n,d)  : 

EXTERNAL  PROC  str .to . screen  (value  rubbishCl)  : 

DEF  high  -  10  ; 

CHAN  BubbleOut, LinearOut, finishl, finiah2: 

PROC  Swap (VAR  V[],  VALUE  i, j)  - 
VAR  Temp  : 

SEQ 

Temp  : -  V [ i ] 

V[i]  V[j] 

V  [  j 1  : ”  Temp  : 

PROC  delay  - 
VAR  count : 

SEQ 

count : “0 

SEQ  i-[0  FOR  1000] 
count :-count+l  : 

PROC  LinearlnsertionSort  - 

VAR  Top, Bottom, CurrentBottom, current, position, Vl(high) : 

SEQ 

Vl(01  -3 

Vl[l]  -1 

Vl[2]  1 

V1C3]  2 

Vl(4]  3 

V1C5I  6 

Vl[6]  0 

V1C7]  9 

Vl[8]  8 

V1C9J  10 

Top  0 
Bottom  high 

SEQ  CurrentBottom  -  [Top  FOR  Bottom] 

SEQ 

current : -CurrentBottom 
WHIIaE  ( (Top)  <  current  ) 

SEQ 

IF 

VI [current]  <  VI [current-l] 

SEQ 

Swap (VI,  current,  current-1) 

LinearOut  !  VI [0]  —  I  Want  the  Screen 

SEQ  i-[l  FOR  high-1] 

LinearOut  !  VI [i] 
current : -current-1 
finishl  !  TRUE; 
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PROC  BubbleSort  - 

VAR  CurrentBottom, Anot:ierPassNeeded, Top, Current, V2 [high] : 

SEQ 

V2[0]  -3 

V2[l]  -1 

V2C21  1 

V2[3)  2 

V2[4]  3 

V2[5]  6 

V2[6)  0 

V2[7]  9 

V2[8]  8 

V2[9)  10 

Top  0 

CurrentBottom  : -  high 
AnotherPaasNeeded  TRUE 

WHILE  AnotherPaasNeeded  AND  (CurrentBottom  >  0) 

SEQ 

AnotherPaasNeeded  FALSE 
SEQ  Current  -  [Top  FOR  CurrentBottom-1 J 
IF 

V2 [Current+l]  <  V2 (Current) 

SEQ 

Swap (V2, Current+l , Current) 

Bubbleout  !  V2[01  —  I  Want  the  Screen 

SEQ  i-(l  FOR  high-1) 

BubbleOut  !  V2[i) 

AnotherPaasNeeded  TRUE 
CurrentBottom  CurrentBottom  -  1 
£inish2  !  TRUE  : 


PROC  ScreenControIler  - 

VAR  activel,active2,temp2 [high] , tempi [high]  : 

SEQ 

activel :-TRUE 
active2 :“TR0E 

WHILE  (activel)  OR  (active2) 

ALT 

BubbleOut  ?  temp2[0] 

SEQ 

SEQ  i-[l  FOR  high-1] 

BubbleOut  ?  temp2[i] 
goto.x.y  (5  ,5) 

SEQ  i-[0  FOR  high] 

SEQ 

delay 

num.to. screen .£ (temp2 [i] ,  3) 
LinearOut  ?  tenpl[0] 

SEQ 

SEQ  i-[l  FOR  high-1 1 
LinearOut  ?  tempi [i] 
goto.x.y  (5,10) 

SEQ  i-[0  FOR  high] 

SEQ 

delay 

num.to. screen . £ (tempi [i] ,  3) 

£ini3hl  ?  ANY 
SEQ 

activel:-  FALSE 
goto.x.y (5, 11) 

atr.to. screen ("  LINEAR  SORT  FINISHED") 
£ini8h2  ?  ANY 


32 


Support  Materials  for  Language  and  System  Support  for  Concurrent  Programming 


SEI-SM-25 


MAIN 


SEQ 

active2:“  FALSE 
goto.x.y (5, 6) 

str.to. screen ("  BUBBLE  SORT  FINISHED")  : 


SEQ 

goto.x.y  (5  ,4) 

str.to. screen  ("  BUBBLESORT  ") 

goto.x.y  (5  ,9) 

str.to. screen ("  LINEARSORT  ") 

PAR 

ScreenController 

LinearlnsertionSort 

BubbleSort 
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Modula-2  Library  Modules  for  Concurrent  Programming 


DEFINITION  MODULE  Process; 

(*  This  module  provides  a  simple  set  of  concurrent  process  services  *) 

(*  including  synchronization  using  binary  semaphores.  *) 

(♦EXPORT  QUALIFIED  Def ineProcess, 

KillProcess, 

GoToSleep, 

StartSystem, 

SIGNAL, 

Init, 

SEND, 

WAIT, 

Awaited; * ) 

TYPE 

SIGNAL;  (*  Defines  a  binary  semaphore.  •) 

PROCEDURE  Def ineProcess (  p:  PROC;  wssize:  CARDINAL  ); 

(*  Add  a  procedure  to  the  list  of  procedures  to  be  executed 
concurrently  with  the  call  to  StartSystem.  The  procedure  p 
must  be  a  parameterless  procedure.  *) 

PROCEDURE  Croak; 

(*  Allows  a  process  to  terminates  its  own  execution  permanently.  *) 
PROCEDURE  GoToSleep; 

(*  Allows  a  process  to  temporarily  suspend  its  own  execution.  It 
is  suspended  and  then  immediately  added  to  the  run  queue.  ♦) 

PROCEDURE  StartSystem; 

(*  The  procedures  specified  by  previous  DefineProcess  calls  are 
executed  pseudo-concurrently.  ♦) 

PROCEDURE  Init(  VAR  a:  SIGNAL  ); 

(*  Initializes  a  user  declared  SIGNAL  (semaphore) .  *) 

PROCEDURE  WAIT(  VAR  s:  SIGNAL  ); 

(♦  Issues  a  wait  operation  on  the  specified  SIGNAL.  ♦) 

PROCEDURE  SENO(  VAR  s:  SIGNAL  ); 

(*  Issues  a  signal  operation  on  the  specified  SIGNAL.  *) 

PROCEDURE  Awaited (  s;  SIGNAL  ) :  BOOLEAN; 

(*  Returns  TRUE  if  there  are  processes  WAITing  on  the  specified  SIGNAL.*) 

END  Process. 


(*  -  *) 


IMPLEMENTATION  MODULE  Process; 

(*  This  module  provides  a  simple  set  of  concurrent  process  services  *) 
(*  including  synchronization  using  binary  semaphores.  *) 

FROM  SYSTEM  IMPORT  ADDRESS,  (*  ADDRESS  type  *) 

NEWPROCESS,  (*  Creates  a  process  *) 

TRANSFER;  (*  Coroutine  transfer  of  control  *) 
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(*  FROM  System  IMPORT  Terminate;  *)  (*  Terminate  program,  exit  to  DOS  *) 


FROM  Storage  IMPORT  ALLOCATE; 


FROM  Queue  IMPORT  Queue,  (*  type  *) 

Qmakeempty,  Qempty,  Qinsert,  Qremove,  Qdefine; 

FROM  InOut  IMPORT  WriteString,  WriteLn; 


TYPE 

SIGNAL  -  POINTER  TO  semaphore; 

semaphore  -  RECORD 

sent  :  BOOLEAN; 
procs:  Queue 
END; 


processptr=  POINTER  TO  ADDRESS; 
VAR 

MAIN  :  processptr; 
currentprocess :  processptr; 
readyqueue  :  Queue; 


PROCEDURE  deadlockhandler; 

BEGIN 

WriteString (' Deadlock  has  occurred'); 
WriteLn; 

TRANSFER(  currentprocess'',  MAIN'  ); 
END  deadlockhandler; 


PROCEDURE  Init(  VAR  s:  SIGNAL  >; 
BEGIN 
NEW (3) ; 

s'. sent  FALSE; 

Qdefine (s' .procs) ; 

Qmakeempty (s' .procs) ; 

END  Init; 


PROCEDURE  SEND(  VAR  3  ;  SIGNAL); 

VAR  prevprocess:  processptr; 

BEGIN 

IF  NOT  Qempty (  s'. procs  )  (*  a  process  is  waiting  on  semaphore  *) 

THEN  Qinsert (  readyqueue,  currentprocess); 
prevprocess  currentprocess; 

Qremove (s' .procs,  currentprocess) ; 

TRANSFER(  prevprocess',  currentprocess'); 

ELSE  3 '.sent  TRUE; 

IF  NOT  Qempty (  readyqueue  ) 

THEN  Qinsert (  readyqueue,  currentprocess); 
prevprocess  currentprocess; 

Qremove (readyqueue,  currentprocess) ; 

TRANSFER(  prevprocess',  currentprocess'); 

END 

END 

END  SEND; 


PROCEDURE  WAIT(  VAR  s:  SIGNAL); 

VAR  prevprocess:  processptr; 
BEGIN 

IF  s'. sent 

THEN  s'. sent  FALSE 

ELSIF  NOT  Qempty (  readyqueue  ) 
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THEN  Qinsert  (  s''.proc3,  currentprocess)  ; 
prevprocess  currentprocess; 

Qremove (readyqueue,  currentprocess) ; 
TRANSFER(  prevprocess'',  currentprocess'); 
ELSE  deadlocJchandler; 

END 

END  WAIT; 

PROCEDURE  Awaited (  s:  SIGNAL):  BOOLEAN; 

BEGIN 

RETURN  NOT  Qempty (s' .procs)  ; 

END  Awaited; 

PROCEDURE  DefineProcess (  p:  PROC;  wssize:  CARDINAL); 

VAR  workspace  :  ADDRESS; 

newprocess  :  processptr; 

BEGIN 

ALLOCATE (  workspace,  wssize); 

NEW(  newprocess  ); 

NEWPROCESS (p,  workspace,  wssize,  newprocess'); 

Qinsert  (  readyqueue,  newprocess) ; 

END  DefineProcess; 

PROCEDURE  GoToSleep; 

VAR  prevprocess  :  processptr; 

BEGIN 

IF  NOT  Qempty (  readyqueue  ) 

THEN  Qinsert (  readyqueue,  currentprocess); 
prevprocess  :»  currentprocess; 

Qremove (readyqueue,  currentprocess) ; 

TRANSFER(  prevprocess',  currentprocess'); 

ELSE  deadlockhandler; 

END; 

END  GoToSleep; 

PROCEDURE  Croak; 

VAR  killedprocess  :  processptr; 

BEGIN 

NEW (  killedprocess  ); 

IF  NOT  Qempty  (  readycjueue  ) 

THEN  Qremove (readyqueue,  currentprocess); 

TRANSFER(  killedprocess',  currentprocess'); 
ELSE  TRANSFER(  killedprocess',  MAIN'); 

END; 

END  Croak; 

PROCEDURE  StartSystem; 

BEGIN 

IF  NOT  Qempty (  readyqueue  ) 

THEN 

NEW(  currentprocess  ); 

NEW(  MAIN  ); 

Qremove (  readyqueue,  currentprocess  ); 

TRANSFER (  MAIN',  currentprocess'  ); 

END; 

END  StartSystem; 

BEGIN  (*  Process  module  initialization  *) 

Qdefine(  readyqueue); 

Qmakeempty (  readyqueue) ; 

END  Process. 
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Queue  Abstract  Data  Type  in  Modula-2 


DEFINITION  MODULE  Queue; 

(*  This  module  exports  a  Queue  abstract  data  type  and  the  supporting  *) 
(*  queue  services:  *) 


(* 

Qdefine 

-  Initializes  a  queue. 

*> 

(* 

Qmakeempty 

-  Force  a  queue  to  empty. 

*) 

(* 

Qinsert 

-  Enqueue  an  item. 

*) 

(* 

Qremove 

-  Remove  the  next  item  from 

1  the  queue  * 

(* 

Qempty 

-  Is  the  queue  empty? 

*) 

FROM  SYSTEM  IMPORT  ADDRESS; 


TYPE  Queue; 

TYPE  Queueltem  -  ADDRESS; 

Qdefine(VAR  Q:  Queue); 

Qempty(Q:  Queue)  :  BOOLEAN; 

Qinsert (VAR  Q:  Queue;  Item:  Queueltem); 
Qmaiceempty  (VAR  Q:  Queue); 

Qremove (VAR  Q:  Queue;  VAR  Item:  Queueltem); 

VAR  Qoverflow:  BOOLEAN; 

Qunderflow:  BOOLEAN; 

END  Queue. 


PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 

PROCEDURE 


(• 


*) 


IMPLEMENTATION  MODULE  Queue; 

FROM  Storage  IMPORT  ALLOCATE,  DEALL0C:ATE; 

TYPE  Queue  -  POINTER  TO  QueueHeader; 

QueueBlockPtr  -  POINTER  TO  QueueBlock; 

QueueBlock  - 
RECORD 

item  :  Queueltem; 
next  :  QueueBlockPtr; 

END; 

QueueHeader  - 
RECORD 

head:  QueueBlockPtr; 
tail:  QueueBlockPtr; 

END; 

PROCEDURE  Qdafine(VAR  Q:  Queue); 

BEGIN 

ALLOCATE (Q, SIZE (QueueHeader) ) ; 

Q''.head  :-  NIL; 

Q^.taii  :-  NIL; 
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END  Qdefine; 


PROCEDURE  Qmakeempty (VAR  Q:  Queue); 

VAR  Qb:  QueueBlocjcPtr; 

BEGiN 

Qb  Q^.head; 

Q^.head  NIL; 

Q^.tail  NIL; 

WHILE  (Qb  <>  NIL)  DO 

DEALL<X:ATE(Qb,  SIZE  (QueueBloc)c) )  ; 

END 

END  Qmakeenpty; 

PROCEDURE  Qenipty(Q:  Queue)  :  BOOLEAN; 

BEGIN 

RETURN  Q*.head-NIL; 

END  Qempty; 

PROCEDURE  Qinsert (VAR  Q:  Queue;  Item;  Queueltem) ; 

VAR  Qb  :  QueueBlockPtr; 

BEGIN 

ALLOCATE (Qb, SIZE (QueueBlock)  )  ; 

Qb''.item  Item; 

Qb''.next  NIL; 

IF  Qempty (Q> 

THEN  Q'^.head  Qb; 

ELSE  Q''. tail next  Qb; 

END; 

Q''.tail  Qb; 

END  Qinsert; 

PROCEDURE  Qremove(VAR  Q;  Queue;  VAR  Item  :  Queueltem); 

VAR  Qb:  QueueBlockPtr; 

BEGIN 

IF  Qempty (Q) 

THEN  Qunderflow  TRUE; 

ELSE  Qb  :*•  Q^.head; 

Q'^.head  Q^ . head'' .next; 

Item  Qb'.item; 

END; 

END  Qremove; 

END  Queue . 
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